home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LISTS
/
READBP
/
READBPA.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1994-11-20
|
15KB
|
424 lines
program ReadBPA;
{Reads Borland BPA Library List File}
{see file ReadBPA.Doc for description and instructions}
uses
crt, dos;
{---------------------------------------------------------------------------}
{file name, value assigned by GetFileName}
const
FileName : string = 'startup';
{---------------------------------------------------------------------------}
{the dynamic array of text from the file,
allocated and filled by ReadBPAFile
then used throughout the program}
type
BPALine = string[77];
const
MaxLines = 7000;
var
BPA : array[1..MaxLines] of ^BPALine;
LineCount : word;
LineIndex : word;
{---------------------------------------------------------------------------}
{redefined extended key codes, as returned by KeyReady}
const
F1 = 128+59; F2 = 128+60; F3 = 128+61; F4 = 128+62; F5 = 128+63;
F6 = 128+64; F7 = 128+65; F8 = 128+66; F9 = 128+67; F10= 128+68;
UpArw = 128+72; DnArw = 128+80; LfArw = 128+75; RtArw = 128+77;
HomKy = 128+71; EndKy = 128+79; PgUp = 128+73; PgDn = 128+81;
AltX = 128+45;
Esc= 27; CR = 13; Bsp= 8; {with a few conventional keys sneaked in}
var
InKey : word;
{---------------------------------------------------------------------------}
{general variables}
const
ExitFlag : boolean = False;
SearchType : byte = 0;
SearchSpec : String[12] = '';
{--------------------------------------------------------------------------}
{file reading procedures}
procedure ShowDirList(FileSpec:string); {list the files available}
var DirInfo: SearchRec;
begin {this is the demo program}
FindFirst(FileSpec, Archive, DirInfo); {from the BP7 help screen}
while DosError = 0 do {for FindFirst, FindNext}
begin {converted to a procedure}
gotoxy(9,WhereY);
writeln(DirInfo.Name);
FindNext(DirInfo);
end;
end; {ShowDirList}
procedure GetFileName(var FileName:string);
var y : byte;
begin
if (filename='startup') and (ParamCount>0) then {command line parameter}
FileName:=ParamStr(1)
else
begin {else get one from the operator}
window(2,3,79,23); clrscr; writeln;
ShowDirList('BPA*.*');
writeln;
writeln('FileName?');
writeln('(1 or 2 digit number will read BPAxx.CAT)');
gotoxy(12,wherey-2);
readln(FileName);
end;
{expand the filename as needed}
case length(FileName) of
0 : ;
1 : FileName:= 'BPA0'+FileName+'.CAT';
2 : FileName:= 'BPA' +FileName+'.CAT';
else if pos('.',FileName) = 0 then FileName:= FileName+'.CAT';
end;
end; {GetFileName}
{$I-}
function FileExist(FileName: String) : Boolean;
var ChkFil : text;
begin
if FileName='' then FileExist:=False
else
begin
Assign(ChkFil,FileName);
Reset(ChkFil);
Close(ChkFil);
FileExist:=(IOResult = 0);
end;
end; {FileExist}
{$I+}
{I-}
procedure ReadBPAFile(FileName:string);
var
i : word;
IsBPA : boolean;
BPAFile : text;
FDat : string[77];
procedure ReadError(ErrNum:byte);
const
ErrMsg : array[1..5] of string[36]
=('Unable to open file',
'Error reading file',
'Too many lines, entire file not read',
'Out of memory, entire file not read',
'No BPA Records found');
var
ch : char;
begin
writeln; writeln; writeln;
writeln(FileName); {show filename}
writeln(ErrMsg[ErrNum]); {show error}
writeln('Esc to halt, any other key to continue...'); {prompt}
ch:=readkey; {wait}
if ord(ch)=Esc then halt else if ch=#0 then ch:=readkey;
end; {ReadError}
begin
if not FileExist(FileName) then {if file not found}
begin
ReadError(1); {alert operator}
LineCount:=0;
exit; {and halt}
end;
for i:=LineCount downto 1 do Dispose(BPA[i]); {free memory}
LineCount:= 0; IsBPA:=False; {initialize counts}
Assign(BPAFile,FileName);
Reset(BPAFile); {open the file}
while (not Eof(BPAFile)) do
begin
if LineCount = MaxLines then {this should never happen}
begin
ReadError(3);
break; {show that portion which was read}
end;
if MaxAvail < SizeOf(BPALine)+8 then {if out of memory}
begin
ReadError(4);
break; {show that portion which was read}
end;
readln(BPAFile,FDat); {read one line of data}
if IOResult<> 0 then {if file is damaged}
begin
ReadError(2);
for i:=LineCount downto 1 do Dispose(BPA[i]); {free memory}
LineCount:=0;
break; {don't try to use it}
end;
{BUT, if no errors}
inc(LineCount);
New(BPA[LineCount]); {allocate memory}
BPA[LineCount]^:=FDat; {and add this line to the array}
if FDat[1]='[' then IsBPA:=True;
end;
Close(BPAFile);
if not IsBPA then {if we didn't find any records}
begin
ReadError(5);
for i:=LineCount downto 1 do Dispose(BPA[i]); {free memory}
LineCount:=0; {report no file read}
end;
end; {ReadBPAFile}
{I+}
{--------------------------------------------------------------------------}
{screen setup procedures}
procedure BorderColor(NewColor: byte); assembler; {from TechInfoNote TI2644}
asm
mov ah, 0Bh
mov bh, 00h
mov bl, NewColor
int 10h
end; {BorderColor}
procedure Frame(X1,Y1,X2,Y2: Integer);
var I : Integer;
begin
window(1,1,80,25);
gotoxy(X1-1,Y1-1);
write(#201);
for I := (X1) to (X2) do write(#205);
write(#187);
for I := (Y1) to (Y2) do
begin
gotoxy(X1-1,I); write(#186);
gotoxy(X2+1,I); write(#186);
end;
gotoxy(X1-1,Y2+1);
write(#200);
for I := (X1) to (X2) do write(#205);
write(#188);
end; {Frame}
procedure DrawScreen;
begin
TextMode(C80); {and draw initial screen}
BorderColor(Blue);
TextBackground(Blue); TextColor(White); clrscr;
write(' ReadBPA');
TextBackground(LightGray); TextColor(Black);
Frame(2,3,79,23); window(2,3,79,23); clrscr;
end; {DrawScreen}
procedure DrawViewWindow;
begin
window(2,1,80,25); TextBackground(Blue); TextColor(White);
write(FileName); {display the filename}
gotoxy(1,25); TextColor(LightGray);
write('Esc: Exit F3: New File ');
write('Searches: F5: Filename F6: Keyword '#17,#196,#217,': Clear');
window(2,3,79,23); TextBackground(LightGray); TextColor(Black);
clrscr;
gotoxy(60,1); writeln('Line Count:',LineCount:5);
end; {DrawViewWindow}
{--------------------------------------------------------------------------}
{search and display procedures}
function BPATop(Index:word):boolean;
begin {first line of each description}
BPATop:= copy(BPA[Index]^,1,1) = '['; {starts with '['}
end;
function Match(Index:word): boolean;
begin
case SearchType of
F5 : Match:= (pos(SearchSpec,BPA[Index+1]^)=1);
{filename at beginning of line 2}
F6 : Match:= (pos(SearchSpec,BPA[Index+4]^+BPA[LineIndex+5]^)<>0);
{keyword anywhere in lines 5 or 6}
else Match:=True;
end; {case}
end; {Match}
procedure SeekForward(StartPoint:Word);
var Index:word;
begin
for Index:= StartPoint+1 to LineCount do {search to end of file}
if BPATop(Index) and Match(Index) then {if found}
begin
LineIndex:=Index; {transfer result}
break;
end;
end; {SeekForward}
procedure SeekReverse(StartPoint:Word);
var Index:word;
begin
for Index:= StartPoint-1 downto 1 do {search to beginning of file}
if BPATop(Index) and Match(Index) then {if found}
begin
LineIndex:=Index; {transfer result}
break;
end;
end; {SeekReverse}
procedure Search(InKey:byte);
const SearchPrompt : array[F5..F6] of string[30]
=('Find File...Enter File Name: ',
'Start Key Search..Enter Key: ');
var i:byte;
begin
case InKey of
F5,F6: begin
gotoxy(3,20);
write(SearchPrompt[InKey]); clreol; {display prompt}
readln(SearchSpec); {get search spec}
if SearchSpec='' then SearchType:=0
else SearchType:=InKey;
end;
else SearchType:=0; {here if InKey = CR}
end;
if SearchType=0 then {no search to be done}
begin
gotoxy(1,20); clreol;
exit;
end;
for i:=1 to length(SearchSpec) do
SearchSpec[i]:= upcase(SearchSpec[i]); {set to uppercase}
gotoxy(32,20); write(SearchSpec); {display it}
SeekForward(0); {seek}
if not Match(LineIndex) then {if not found}
begin
SearchType:=0; {clear search}
gotoxy(45,20); write('NOT FOUND'); {and alert operator}
sound(220); delay(200); nosound;
end;
end; {Search}
procedure ShowBPA;
var i: byte; ThisBPA:boolean;
begin
window(2,4,79,24);
write(BPA[LineIndex]^); clreol; {write first line this record}
gotoxy(60,1); writeln('Line Index:',LineIndex:5);
ThisBPA:=True; {This is the whole reason for this program}
for i:=1 to 18 do {up to 19 lines per description}
begin
if BPATop(LineIndex+i) then {if top of next one}
ThisBPA:=False; {write no more}
if ThisBPA and (LineIndex+i <= LineCount) then {and not past end}
write(BPA[LineIndex+i]^);
clreol; writeln;
end;
end; {ShowBPA}
procedure NewFile;
var i:word;
begin
repeat
GetFileName(FileName);
ReadBPAFile(FileName); {has operator halt option if unable to read}
until LineCount>0;
DrawViewWindow;
SearchType:=0;
SeekForward(0); {find first}
ShowBPA;
end; {NewFile}
{--------------------------------------------------------------------------}
{key handling procedures}
function KeyReady(var InKey:word):boolean; {True if a key is available}
{adapted from \bp\examples\utils\prnfltr.pas function GetKey}
var Key:byte;
begin
InKey:=0;
if KeyPressed then
begin
Key:=ord(ReadKey);
case Key of
1..127 : InKey:=Key; {standard key}
0 : begin {extended key}
Key:=ord(ReadKey);
case Key of
1..127 : InKey:=128 + Key; {new extended key values}
end;
end;
end;
end;
{all keys which would normally be reported as extended keys}
{now return 128 + their normal value}
{except F11 and F12 combinations, which this program doesn't use}
KeyReady:=InKey<>0;
end; {KeyReady}
procedure KeyHandler(InKey:byte);
var SaveLineIndex : word;
begin
if SearchType=0 then begin gotoxy(1,20); clreol; end; {clear old prompt}
SaveLineIndex:=LineIndex; {used below to decide whether to show}
case InKey of
Esc,AltX : begin ExitFlag:=True; exit; end; {exit}
HomKy : SeekForward(0); {find first}
EndKy : SeekReverse(LineCount); {find last}
DnArw,PgDn : SeekForward(LineIndex); {find next}
UpArw,PgUp : SeekReverse(LineIndex); {find prev}
F5,F6,CR : Search(InKey); {search}
F3 : NewFile;
end;
if LineIndex <> SaveLineIndex then
begin
ShowBPA; {if moved, show new record}
if SearchType = 0 then gotoxy(3,20)
else gotoxy(45,20);
clreol;
end
else case InKey of HomKy,UpArw,PgUp,EndKy,DnArw,PgDn :
begin
if SearchType = 0 then gotoxy(3,20)
else gotoxy(45,20);
write('No More');
end;
end;
end; {KeyHandler}
{--------------------------------------------------------------------------}
{initialization and exit}
var
SaveExit : pointer;
SaveTextAttr : byte;
{$F+}
procedure ExitReadBPA;
var i: word;
begin
ExitProc:= SaveExit; {restore exit procedure address}
TextMode(C80); TextAttr:=SaveTextAttr; clrscr;{restore screen attributes}
BorderColor((TextAttr and $70) div 16); {and border color}
end; {ExitReadBPA}
{$F-}
procedure Init;
begin
SaveExit:= ExitProc; {save previous exit proc}
ExitProc:= @ExitReadBPA; {setup exit procedure}
SaveTextAttr:=TextAttr; {save text mode and color for exit}
DrawScreen;
end; {Init}
BEGIN
Init;
NewFile;
repeat
if KeyReady(InKey) then KeyHandler(InKey);
until ExitFlag;
END.